            
{ Copyright (C) 2009, Serge Voloshenyuk
  
  This file is Free Software and part of DCocoR
  
  It is licensed under the following three licenses as alternatives:
    1. GNU Lesser General Public License (LGPL) V2.1 or any newer version
    2. GNU General Public License (GPL) V2 or any newer version
    3. Apache License, V2.0 or any newer version
  
  You may not use this file except in compliance with at least one of
  the above three licenses.
  
  See LICENSE.txt at the top of this package for the
  complete terms and further detail along with the license texts for
  the licenses in COPYING-LIB.txt, COPYING.txt and LICENSE-2.0.txt respectively.
} 

{ This unit was generated by DCocoR.  
  Any code in this file that you edit manually will be over-written when the file is regenerated.
}

unit DelphiCond;

interface

uses Classes,CocoAncestor,
         SysUtils,Variants,StrUtils;

type


  TDelphiCondScanner = class(TCocoRScanner)
  public
    procedure SkipIgnoreSet; override;
    procedure ScanSym(state: Integer; var sym: Integer); override;
    
  end;


  TDelphiCond = class(TCocoRGrammar)
  private             
    fVersion: Integer;
    fDefinesStr: String;
    procedure setVersion(const Value: Integer);
    procedure setDefinesStr(const Value: String);

  protected
              
  fDefines: TStringList;
  function IsDefined(const id: String): Boolean;
  procedure setDefined(const id: String; val: Boolean);
  function IsDeclared(const str: String): Boolean;
  function getValueFor(const str: String): Variant;
  function Functor(FuncOp: Integer; Value: Variant): Variant;

    procedure _DelphiCond;
    procedure _Expression(var Value: Variant);
    procedure _SimpleExpression(var Value: Variant);
    procedure _Term(var Value: Variant);
    procedure _Factor(var Value: Variant);
    procedure _Number(out Value: Variant);
    procedure _functor(var Value: Variant);

  public
           
  destructor Destroy; override;

  function Evaluate(const str: String): Boolean;


    function  ErrorMessage(ErrorType,ErrorCode: Integer; const data: string): String; override;
    function  TokenToString(n: Integer): String; override;
    function  CreateScanner: TBaseScanner; override;
    function Execute: Boolean; override;

    constructor Create(AOwner: TComponent); override;
                 
 property Defined[const name: String]: Boolean read IsDefined write setDefined;
 property Version: Integer read fVersion write setVersion;
 property Defines: String read fDefinesStr write setDefinesStr;

  end;

implementation

const

	identSym = 1;	numberSym = 2;	stringSym = 3;	floatSym = 4;	hexnumberSym = 5;
	eqSym = 6;	grSym = 7;	lesSym = 8;	lesEqSym = 9;	grEqSym = 10;
	noeqSym = 11;	addSym = 12;	subSym = 13;	orSym = 14;	xorSym = 15;
	multSym = 16;	divdSym = 17;	divSym = 18;	modSym = 19;	andSym = 20;
	shlSym = 21;	shrSym = 22;	DEFINEDSym = 23;	_lparenSym = 24;	_rparenSym = 25;
	DECLAREDSym = 26;	TRUESym = 27;	FALSESym = 28;	NOTSym = 29;	ABSSym = 30;
	CHRSym = 31;	HISym = 32;	HIGHSym = 33;	LENGTHSym = 34;	LOSym = 35;
	LOWSym = 36;	ODDSym = 37;	ORDSym = 38;	PREDSym = 39;	ROUNDSym = 40;
	SIZEOFSym = 41;	SUCCSym = 42;	SWAPSym = 43;	TRUNCSym = 44;	_NOSYMB = 45;


var DelphiCondSymSets: TSetArray;


var
  DelphiCondST: TStartTable = nil;
  DelphiCondLiterals: TStringList = nil;

{ TDelphiCondScanner }

procedure TDelphiCondScanner.ScanSym(state: Integer; var sym: Integer);
 var apx: TSymbolRec;
begin
 apx.Beg := -1;

 while True do
 begin
  NextCh;
  case state of
	 1:
		if ((CurrInputCh>='0')and(CurrInputCh<='9'))or((CurrInputCh>='A')and(CurrInputCh<='Z'))or(CurrInputCh='_') then
		else begin
		  sym := identSym;
		  CheckLiteral(sym);
		  Exit;
		end;
	 2:
		begin
		  EndContext(apx);
		  sym := numberSym;
		  Exit;
		end;
	 3:
		if (CurrInputCh = '''') then
		  state := 4
		else if (CurrInputCh = '#') then
		  state := 5
		else begin
		  sym := stringSym;
		  Exit;
		end;
	 4:
		if not(((CurrInputCh>=#1)and(CurrInputCh<=#31))or(CurrInputCh='''')) then
		else if (CurrInputCh = '''') then
		  state := 3
		else begin
		  sym := _NOSYMB;
		  Exit;
		end;
	 5:
		if ((CurrInputCh>='0')and(CurrInputCh<='9')) then
		  state := 6
		else if (CurrInputCh = '$') then
		  state := 7
		else begin
		  sym := _NOSYMB;
		  Exit;
		end;
	 6:
		if ((CurrInputCh>='0')and(CurrInputCh<='9')) then
		else if (CurrInputCh = '''') then
		  state := 4
		else if (CurrInputCh = '#') then
		  state := 5
		else begin
		  sym := stringSym;
		  Exit;
		end;
	 7:
		if ((CurrInputCh>='0')and(CurrInputCh<='9'))or((CurrInputCh>='A')and(CurrInputCh<='F')) then
		  state := 8
		else begin
		  sym := _NOSYMB;
		  Exit;
		end;
	 8:
		if ((CurrInputCh>='0')and(CurrInputCh<='9'))or((CurrInputCh>='A')and(CurrInputCh<='F')) then
		else if (CurrInputCh = '''') then
		  state := 4
		else if (CurrInputCh = '#') then
		  state := 5
		else begin
		  sym := stringSym;
		  Exit;
		end;
	 9:
		if not(((CurrInputCh>=#1)and(CurrInputCh<=#31))or(CurrInputCh='''')) then
		else if (CurrInputCh = '''') then
		  state := 3
		else begin
		  sym := _NOSYMB;
		  Exit;
		end;
	10:
		if ((CurrInputCh>='0')and(CurrInputCh<='9')) then
		  state := 11
		else if (CurrInputCh = '$') then
		  state := 12
		else begin
		  sym := _NOSYMB;
		  Exit;
		end;
	11:
		if ((CurrInputCh>='0')and(CurrInputCh<='9')) then
		else if (CurrInputCh = '''') then
		  state := 4
		else if (CurrInputCh = '#') then
		  state := 5
		else begin
		  sym := stringSym;
		  Exit;
		end;
	12:
		if ((CurrInputCh>='0')and(CurrInputCh<='9'))or((CurrInputCh>='A')and(CurrInputCh<='F')) then
		  state := 13
		else begin
		  sym := _NOSYMB;
		  Exit;
		end;
	13:
		if ((CurrInputCh>='0')and(CurrInputCh<='9'))or((CurrInputCh>='A')and(CurrInputCh<='F')) then
		else if (CurrInputCh = '''') then
		  state := 4
		else if (CurrInputCh = '#') then
		  state := 5
		else begin
		  sym := stringSym;
		  Exit;
		end;
	14:
		if ((CurrInputCh>='0')and(CurrInputCh<='9')) then
		else if (CurrInputCh = 'E') then
		  state := 15
		else begin
		  sym := floatSym;
		  Exit;
		end;
	15:
		if ((CurrInputCh>='0')and(CurrInputCh<='9')) then
		  state := 17
		else if (CurrInputCh='+')or(CurrInputCh='-') then
		  state := 16
		else begin
		  sym := _NOSYMB;
		  Exit;
		end;
	16:
		if ((CurrInputCh>='0')and(CurrInputCh<='9')) then
		  state := 17
		else begin
		  sym := _NOSYMB;
		  Exit;
		end;
	17:
		if ((CurrInputCh>='0')and(CurrInputCh<='9')) then
		else begin
		  sym := floatSym;
		  Exit;
		end;
	18:
		if ((CurrInputCh>='0')and(CurrInputCh<='9')) then
		  state := 20
		else if (CurrInputCh='+')or(CurrInputCh='-') then
		  state := 19
		else begin
		  sym := _NOSYMB;
		  Exit;
		end;
	19:
		if ((CurrInputCh>='0')and(CurrInputCh<='9')) then
		  state := 20
		else begin
		  sym := _NOSYMB;
		  Exit;
		end;
	20:
		if ((CurrInputCh>='0')and(CurrInputCh<='9')) then
		else begin
		  sym := floatSym;
		  Exit;
		end;
	21:
		if ((CurrInputCh>='0')and(CurrInputCh<='9'))or((CurrInputCh>='A')and(CurrInputCh<='F')) then
		  state := 22
		else begin
		  sym := _NOSYMB;
		  Exit;
		end;
	22:
		if ((CurrInputCh>='0')and(CurrInputCh<='9'))or((CurrInputCh>='A')and(CurrInputCh<='F')) then
		else begin
		  sym := hexnumberSym;
		  Exit;
		end;
	23:
		begin
		  sym := eqSym;
		  Exit;
		end;
	24:
		begin
		  sym := lesEqSym;
		  Exit;
		end;
	25:
		begin
		  sym := grEqSym;
		  Exit;
		end;
	26:
		begin
		  sym := noeqSym;
		  Exit;
		end;
	27:
		begin
		  sym := addSym;
		  Exit;
		end;
	28:
		begin
		  sym := subSym;
		  Exit;
		end;
	29:
		begin
		  sym := multSym;
		  Exit;
		end;
	30:
		begin
		  sym := divdSym;
		  Exit;
		end;
	31:
		if ((CurrInputCh>='0')and(CurrInputCh<='9')) then
		else if (CurrInputCh = '.') then
		begin   state := 34; BeginContext(apx); end
		else if (CurrInputCh = 'E') then
		  state := 18
		else begin
		  sym := numberSym;
		  Exit;
		end;
	32:
		if (CurrInputCh = '=') then
		  state := 25
		else begin
		  sym := grSym;
		  Exit;
		end;
	33:
		if (CurrInputCh = '=') then
		  state := 24
		else if (CurrInputCh = '>') then
		  state := 26
		else begin
		  sym := lesSym;
		  Exit;
		end;
	34:
		if ((CurrInputCh>='0')and(CurrInputCh<='9')) then
		begin   state := 14; apx.Beg := -1; end
		else if (CurrInputCh = '.') then
		begin   state := 2; BeginContext(apx); end
		else if (CurrInputCh = 'E') then
		begin   state := 15; apx.Beg := -1; end
		else begin
		  sym := floatSym;
		  Exit;
		end;
	35:
		begin
		  sym := _lparenSym;
		  Exit;
		end;
	36:
		begin
		  sym := _rparenSym;
		  Exit;
		end;
  
    else begin
      if CurrInputCh=#0 then
           sym := _EOFSYMB
      else sym := _NOSYMB;
      Exit;
    end;
  end;
 end;
end;


procedure TDelphiCondScanner.SkipIgnoreSet;
begin
  while (CurrInputCh = ' ') or 
    ( (CurrInputCh=#9)or(CurrInputCh=#10)or(CurrInputCh=#13) )
  do NextCh;
end;




{ TDelphiCond }


destructor TDelphiCond.Destroy; 
begin
  fDefines.Free;
  inherited;
end;

function TDelphiCond.Evaluate(const str: String): Boolean;
var rez: Variant; 
begin
  SetSource(str);
  _Expression(rez);
  Result := Successful and rez;
end;

function TDelphiCond.IsDefined(const id: String): Boolean;
var I: Integer;
begin
  Result := fDefines.Find(id,I);
end;

procedure TDelphiCond.setDefined(const id: String; val: Boolean);
var I: Integer;
begin
  with fDefines do 
  if Find(id,I) then
  begin
    if not val then Delete(I);
  end else if val then fDefines.Add(id);
end;

function TDelphiCond.IsDeclared(const str: String): Boolean;
begin
  raise Exception.Create('Predicate "Declared" is not implemented');
end;

function TDelphiCond.getValueFor(const str: String): Variant;
begin
  Result := str;
//  raise Exception.Create('Feature is not implemented: '+Scanner.Source);
end;

function TDelphiCond.Functor(FuncOp: Integer; Value: Variant): Variant;
begin
  case FuncOp of
  SIZEOFSym:
     case IndexText(VarToStr(Value),['CHAR','INTEGER','POINTER']) of
       0: Result := 1;
       1,2: Result := 4;
       else raise Exception.CreateFmt('Sizeof(%s) id not implemented',[VarToStr(Value)]);
     end;
  else raise Exception.CreateFmt('Functions are not implemented: %s',[Scanner.Source]);
  end;
end;

procedure TDelphiCond.setDefinesStr(const Value: String);
begin
  fDefinesStr := Value;
  fDefines.CommaText := Format('%s,VER%d',[Value,fVersion]);
end;

procedure TDelphiCond.setVersion(const Value: Integer);
begin
  fVersion := Value;
  fDefines.CommaText := Format('%s,VER%d',[fDefinesStr,fVersion]);
end;


procedure TDelphiCond._DelphiCond;
 var rez: Variant; 
begin
  _Expression(rez);
end;

procedure TDelphiCond._Expression(var Value: Variant);
 var v2: Variant; RelOp: Integer; 
begin
  _SimpleExpression(Value);
  while InSet(CurrentInputSymbol,0) do
  begin
    if (CurrentInputSymbol=eqSym) then
    begin
         Get;
    end
    else if (CurrentInputSymbol=grSym) then
    begin
         Get;
    end
    else if (CurrentInputSymbol=lesSym) then
    begin
         Get;
    end
    else if (CurrentInputSymbol=lesEqSym) then
    begin
         Get;
    end
    else if (CurrentInputSymbol=grEqSym) then
    begin
         Get;
    end
    else if (CurrentInputSymbol=noeqSym) then
    begin
         Get;
    end
    ;
      RelOp := Symbols[0]^.id; 
    _SimpleExpression(v2);
      case RelOp of
      eqSym:    Value := Value=v2;
      grSym:    Value := Value>v2;
      lesSym:   Value := Value<v2;
      lesEqSym: Value := Value<=v2;
      grEqSym:  Value := Value>=v2;
      noeqSym:  Value := Value<>v2;
      end;
   
  end;
end;

procedure TDelphiCond._SimpleExpression(var Value: Variant);
 var v2: Variant; sign: Integer; AddOp: Integer; 
begin
    sign := 1;
  if (CurrentInputSymbol in [addSym, subSym]) then
  begin
    if (CurrentInputSymbol=addSym) then
    begin
         Get;
    end
    else if (CurrentInputSymbol=subSym) then
    begin
         Get;
               sign := -1;
    end
    ;
  end;
  _Term(Value);
                 if sign<0 then value := -value;
  while InSet(CurrentInputSymbol,1) do
  begin
    if (CurrentInputSymbol=addSym) then
    begin
         Get;
    end
    else if (CurrentInputSymbol=subSym) then
    begin
         Get;
    end
    else if (CurrentInputSymbol=orSym) then
    begin
         Get;
    end
    else if (CurrentInputSymbol=xorSym) then
    begin
         Get;
    end
    ;
      AddOp := Symbols[0]^.id; 
    _Term(v2);
      case AddOp of
      addSym: Value := Value +   v2;
      subSym: Value := Value -   v2;
      orSym : Value := Value or  v2;
      xorSym: Value := Value xor v2;
      end;
   
  end;
end;

procedure TDelphiCond._Term(var Value: Variant);
 var v2: Variant; MulOp: Integer; 
begin
  _Factor(Value);
  while InSet(CurrentInputSymbol,2) do
  begin
    if (CurrentInputSymbol=multSym) then
    begin
         Get;
    end
    else if (CurrentInputSymbol=divdSym) then
    begin
         Get;
    end
    else if (CurrentInputSymbol=divSym) then
    begin
         Get;
    end
    else if (CurrentInputSymbol=modSym) then
    begin
         Get;
    end
    else if (CurrentInputSymbol=andSym) then
    begin
         Get;
    end
    else if (CurrentInputSymbol=shlSym) then
    begin
         Get;
    end
    else if (CurrentInputSymbol=shrSym) then
    begin
         Get;
    end
    ;
     MulOp := Symbols[0]^.id; 
    _Factor(v2);
      case MulOp of
      multSym: Value := Value *   v2;
      divdSym: Value := Value /   v2;
      divSym:  Value := Value div v2;
      modSym:  Value := Value mod v2;
      andSym:  Value := Value and v2;
      shlSym:  Value := Value shl v2;
      shrSym:  Value := Value shr v2;
      end;
   
  end;
end;

procedure TDelphiCond._Factor(var Value: Variant);
begin
  if (CurrentInputSymbol=DEFINEDSym) then
  begin
       Get;
       Expect(_lparenSym);
       Expect(identSym);
                            Value := IsDefined(LexName);  
       Expect(_rparenSym);
  end
  else if (CurrentInputSymbol=DECLAREDSym) then
  begin
       Get;
       Expect(_lparenSym);
       Expect(identSym);
                            Value := IsDeclared(LexName); 
       Expect(_rparenSym);
  end
  else if (CurrentInputSymbol=stringSym) then
  begin
       Get;
                               Value := LexString; 
  end
  else if (CurrentInputSymbol=TRUESym) then
  begin
       Get;
                               Value := True; 
  end
  else if (CurrentInputSymbol=FALSESym) then
  begin
       Get;
                               Value := False; 
  end
  else if (CurrentInputSymbol=NOTSym) then
  begin
       Get;
       _Factor(Value);
                               Value := not Value; 
  end
  else if (CurrentInputSymbol=identSym) then
  begin
       Get;
                               Value := getValueFor(LexName);
  end
  else if (CurrentInputSymbol in [numberSym, floatSym, hexnumberSym]) then
  begin
       _Number(Value);
  end
  else if InSet(CurrentInputSymbol,3) then
  begin
       _functor(Value);
  end
  else if (CurrentInputSymbol=_lparenSym) then
  begin
       Get;
       _Expression(Value);
       Expect(_rparenSym);
  end
  else SynError(1);
end;

procedure TDelphiCond._Number(out Value: Variant);
begin
  if (CurrentInputSymbol=numberSym) then
  begin
       Get;
                 Value := StrToInt(LexString); 
  end
  else if (CurrentInputSymbol=floatSym) then
  begin
       Get;
                 Value := StrToFloat(LexString); 
  end
  else if (CurrentInputSymbol=hexnumberSym) then
  begin
       Get;
                 Value := StrToInt(LexString); 
  end
  else SynError(2);
end;

procedure TDelphiCond._functor(var Value: Variant);
 var FuncOp: Integer; 
begin
  if (CurrentInputSymbol=ABSSym) then
  begin
       Get;
  end
  else if (CurrentInputSymbol=CHRSym) then
  begin
       Get;
  end
  else if (CurrentInputSymbol=HISym) then
  begin
       Get;
  end
  else if (CurrentInputSymbol=HIGHSym) then
  begin
       Get;
  end
  else if (CurrentInputSymbol=LENGTHSym) then
  begin
       Get;
  end
  else if (CurrentInputSymbol=LOSym) then
  begin
       Get;
  end
  else if (CurrentInputSymbol=LOWSym) then
  begin
       Get;
  end
  else if (CurrentInputSymbol=ODDSym) then
  begin
       Get;
  end
  else if (CurrentInputSymbol=ORDSym) then
  begin
       Get;
  end
  else if (CurrentInputSymbol=PREDSym) then
  begin
       Get;
  end
  else if (CurrentInputSymbol=ROUNDSym) then
  begin
       Get;
  end
  else if (CurrentInputSymbol=SIZEOFSym) then
  begin
       Get;
  end
  else if (CurrentInputSymbol=SUCCSym) then
  begin
       Get;
  end
  else if (CurrentInputSymbol=SWAPSym) then
  begin
       Get;
  end
  else if (CurrentInputSymbol=TRUNCSym) then
  begin
       Get;
  end
  else SynError(3);
      FuncOp := Symbols[0]^.id; 
  Expect(_lparenSym);
  _SimpleExpression(Value);
  Expect(_rparenSym);
     Value := Functor(FuncOp,Value); 
end;



function TDelphiCond.TokenToString(n: Integer): String;
const TokenStrings: array[0.._NOSYMB] of String = ('EOF'
	,'ident'	,'number'	,'string'	,'float'	,'hexnumber'
	,'"="'	,'">"'	,'"<"'	,'"<="'	,'">="'
	,'"<>"'	,'"+"'	,'"-"'	,'"OR"'	,'"XOR"'
	,'"*"'	,'"/"'	,'"DIV"'	,'"MOD"'	,'"AND"'
	,'"SHL"'	,'"SHR"'	,'"DEFINED"'	,'"("'	,'")"'
	,'"DECLARED"'	,'"TRUE"'	,'"FALSE"'	,'"NOT"'	,'"ABS"'
	,'"CHR"'	,'"HI"'	,'"HIGH"'	,'"LENGTH"'	,'"LO"'
	,'"LOW"'	,'"ODD"'	,'"ORD"'	,'"PRED"'	,'"ROUND"'
	,'"SIZEOF"'	,'"SUCC"'	,'"SWAP"'	,'"TRUNC"'  ,'not');
begin
  if n in [0.._NOSYMB] then
    Result := TokenStrings[n]
  else Result := '?';
end;

function TDelphiCond.ErrorMessage(ErrorType, ErrorCode: Integer; const data: string): String;
begin
  case ErrorCode of
	1 : Result := 'invalid Factor';
	2 : Result := 'invalid Number';
	3 : Result := 'invalid functor';


    else Result := inherited ErrorMessage(ErrorType, ErrorCode,data);
  end;
end;



function TDelphiCond.Execute: Boolean;
begin
  Reinit;
  _DelphiCond;
  Result := Successful;
end;


function TDelphiCond.CreateScanner: TBaseScanner;
begin
  Result := TDelphiCondScanner.Create(Self);
  if DelphiCondST=nil then
  begin
    DelphiCondST := TStartTable.Create;
    with DelphiCondST do
    begin
	  FillRange(65, 90, 1);  States[95] := 1;  FillRange(48, 57, 31);  States[39] := 9;
	  States[35] := 10;  States[36] := 21;  States[61] := 23;  States[62] := 32;  States[60] := 33;
	  States[43] := 27;  States[45] := 28;  States[42] := 29;  States[47] := 30;  States[40] := 35;
	  States[41] := 36;
    end;
    DelphiCondLiterals := CreateLiterals(False,
	['OR','XOR','DIV','MOD','AND','SHL','SHR','DEFINED','DECLARED','TRUE','FALSE','NOT','ABS','CHR','HI','HIGH','LENGTH','LO'
		,'LOW','ODD','ORD','PRED','ROUND','SIZEOF','SUCC','SWAP','TRUNC'],
	[orSym,xorSym,divSym,modSym,andSym,shlSym,shrSym,DEFINEDSym,DECLAREDSym,TRUESym,FALSESym,NOTSym,ABSSym,CHRSym,HISym,HIGHSym
		,LENGTHSym,LOSym,LOWSym,ODDSym,ORDSym,PREDSym,ROUNDSym,SIZEOFSym,SUCCSym,SWAPSym,TRUNCSym]
     );
  end;
  with TDelphiCondScanner(Result) do
  begin
    CaseInsensitive := True;  
    noSym := _NOSYMB;
    StartState := DelphiCondST;
    Literals := DelphiCondLiterals;
  end;
end;


constructor TDelphiCond.Create(AOwner: TComponent);
begin
              
  fDefines := TStringList.Create;
  with fDefines do
  begin
    Sorted := True;
    CaseSensitive := False;
    Duplicates := dupIgnore;
  end;  
  fVersion := 185;
  Defines := 'MSWINDOWS,WIN32,CPU386';
  
  inherited;

  if Length(DelphiCondSymSets)=0 then
  InitSymSets(DelphiCondSymSets,[
    	{ 0} eqSym, grSym, lesSym, lesEqSym, grEqSym, noeqSym, -1,
	{ 1} addSym, subSym, orSym, xorSym, -1,
	{ 2} multSym, divdSym, divSym, modSym, andSym, shlSym, shrSym, -1,
	{ 3} ABSSym, CHRSym, HISym, HIGHSym, LENGTHSym, LOSym, LOWSym, ODDSym, ORDSym, PREDSym, ROUNDSym, SIZEOFSym, SUCCSym, SWAPSym, TRUNCSym
  ]); 
  SymSets := DelphiCondSymSets;
  
end;

end.

